home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / anirot_1 / frmfontr.frm (.txt) next >
Visual Basic Form  |  1999-01-13  |  4KB  |  122 lines
  1. VERSION 5.00
  2. Begin VB.Form frmFontRotation 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H80000007&
  5.    Caption         =   "Form1"
  6.    ClientHeight    =   5235
  7.    ClientLeft      =   60
  8.    ClientTop       =   345
  9.    ClientWidth     =   6735
  10.    ForeColor       =   &H000000FF&
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   349
  13.    ScaleMode       =   3  'Pixel
  14.    ScaleWidth      =   449
  15.    StartUpPosition =   3  'Windows Default
  16. Attribute VB_Name = "frmFontRotation"
  17. Attribute VB_GlobalNameSpace = False
  18. Attribute VB_Creatable = False
  19. Attribute VB_PredeclaredId = True
  20. Attribute VB_Exposed = False
  21. 'Rotating Text Sample
  22. 'Author: S
  23. ren Christensen
  24. 'Date: 13-01-99
  25. Option Explicit
  26. 'API's used in this sample
  27. Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal U As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
  28. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  29. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  30. Private Declare Function GetTickCount Lib "kernel32" () As Long
  31. 'Constant text to draw
  32. Const TEXTOUTPUT As String = "www.vbexplorer.com"
  33. Const PI As Single = 3.141593
  34. 'API constants
  35. Const ANSI_CHARSET As Long = 0
  36. Const FF_DONTCARE As Long = 0
  37. Const CLIP_LH_ANGLES As Long = &H10
  38. Const CLIP_DEFAULT_PRECIS As Long = 0
  39. Const OUT_TT_ONLY_PRECIS As Long = 7
  40. Const PROOF_QUALITY As Long = 2
  41. Const TRUETYPE_FONTTYPE As Long = &H4
  42. Const p_WIDTH As Long = 12
  43. Const p_HEIGHT As Long = 12
  44. 'Center coordinates
  45. Dim pXCenter As Long
  46. Dim pYCenter As Long
  47. 'LookUp table with relative coordinates
  48. Dim LookUp(1 To 2, 1 To 36) As Long
  49. Dim pRadius As Long
  50. 'ending flag
  51. Dim TimeToEnd As Boolean
  52. 'Main animation procedure
  53. Private Sub RunMain()
  54. Const FrameInterval As Long = 35
  55. Dim LastFrameTime As Long
  56. Dim Angle As Long
  57. 'Show the form
  58. Me.Show
  59. Angle = 1800
  60.     'check to see if we have to end
  61.     If TimeToEnd Then Exit Do
  62.         
  63.         If GetTickCount() - LastFrameTime > FrameInterval Then  'Time to update
  64.             
  65.             'update angle
  66.             Angle = (Angle Mod 3600) - 100
  67.             'clear the form
  68.             Me.Cls
  69.             
  70.             DrawRotatedText Angle
  71.             
  72.             LastFrameTime = GetTickCount()
  73.                         
  74.         End If
  75.         
  76.     DoEvents
  77. End Sub
  78. 'Draws the rotated text
  79. Private Sub DrawRotatedText(Angle As Long)
  80. Dim NewFont As Long
  81. Dim OldFont As Long
  82. Static I As Long
  83. 'creat the font
  84. NewFont = CreateFont(p_HEIGHT, p_WIDTH, Angle, 0, FF_DONTCARE, 0, 0, 0, ANSI_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Arial")
  85. 'set the new font
  86. OldFont = SelectObject(Me.hdc, NewFont)
  87. I = (I Mod 36) + 1
  88. CurrentX = pXCenter + LookUp(1, I)
  89. CurrentY = pYCenter + LookUp(2, I)
  90. Print TEXTOUTPUT
  91. 'set the old font back
  92. NewFont = SelectObject(Me.hdc, OldFont)
  93. 'Clean up
  94. DeleteObject NewFont
  95. End Sub
  96. Private Sub Form_Load()
  97. pRadius = ((Len(TEXTOUTPUT) * p_WIDTH) / 2)
  98. BuildLookupTable
  99. RunMain
  100. End Sub
  101. Private Sub Form_Resize()
  102. 'calculate center
  103. pXCenter = Me.ScaleWidth / 2
  104. pYCenter = Me.ScaleHeight / 2
  105. End Sub
  106. Private Sub Form_Unload(Cancel As Integer)
  107. 'flag the end
  108. TimeToEnd = True
  109. End Sub
  110. 'Builds the lookup table with the circle coordinates
  111. Private Sub BuildLookupTable()
  112. Dim I As Long
  113. Dim Angle As Long
  114. Const XIndex As Long = 1
  115. Const YIndex As Long = 2
  116. For I = LBound(LookUp, 2) To UBound(LookUp, 2)
  117.     LookUp(XIndex, I) = CLng(Cos((Angle * PI / 180)) * pRadius)
  118.     LookUp(YIndex, I) = CLng(Sin((Angle * PI / 180)) * pRadius)
  119.     Angle = (Angle Mod 360) + 10
  120. Next I
  121. End Sub
  122.